home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / pctj8411.arc / INFORM.BAS < prev    next >
BASIC Source File  |  1986-09-14  |  2KB  |  58 lines
  1. 100 PRINT "INF version 83/06/12"
  2. 105 DEFINT A-Z
  3. 199 ON ERROR GOTO 9800
  4. 200 DEF FNS$(N)=MID$(STR$(N),2)
  5. 205 DEF FNN$(N,L)=MID$(STR$(N+10^L),3,L)
  6. 400 REM      1   2   3   4   5   6   7   8   9  10
  7. 405 C0$="   DAT TEX ALP COD NUM TOT PHO MED SSN STO"
  8. 410 P0$="   PAC UNP STO"
  9. 415 A0$="ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 -,."
  10. 900 PRINT " ";M$
  11. 1000 PRINT:GOSUB 9700:INPUT "TYPE,WORD";C$,T$:PRINT
  12. 1005 C0=INSTR(C0$,LEFT$(C$,3))/4:M$="Bad type"
  13. 1010 ON 1+C0 GOTO 900,3100,3200,3300,3400,3500,3600,3700,3800,3900,9999
  14. 1015 REM          TYP DAT  TEX  ALP  COD  NUM  TOT  PHO  MED  SSN  STO
  15. 3100 M$=T$:GOSUB 7100:M$=M$+" to "+STR$(CVI(T$))+" to "
  16. 3105 GOSUB 7150:M$=M$+T$:GOTO 900
  17. 3200 M$="Not ready":GOTO 900
  18. 3300 M$=T$:GOSUB 7300:M$=M$+" to "+STR$(LEN(T$))+" chars to "
  19. 3305 GOSUB 7350:M$=M$+T$:GOTO 900
  20. 3400 M$="Not ready":GOTO 900
  21. 3500 M$="Not ready":GOTO 900
  22. 3600 M$="Not ready":GOTO 900
  23. 3700 M$="Not ready":GOTO 900
  24. 3800 M$="Not ready":GOTO 900
  25. 3900 M$="Not ready":GOTO 900
  26. 7100 IF T$="00/00/00" THEN T$=MKI$(0):RETURN
  27. 7105 T0$=LEFT$(T$,1):T1$=MID$(T$,2,1)
  28. 7110 T2$=MID$(T$,4,2):T3$=MID$(T$,7)
  29. 7115 M!=VAL(T2$):D=VAL(T3$)
  30. 7120 IF T0$<"A" THEN Y=VAL(T0$+T1$) ELSE Y=10*(ASC(T0$)-55)+VAL(T1$)
  31. 7125 X!=365*(Y-1)+31*(M!-1)+D:I=Y:IF M!>2 THEN X!=X!-INT(.4*M!+2.3):I=Y+1
  32. 7130 X!=X!+INT((I-1)/4):IF X!>=32768! THEN X=X!-65536! ELSE X=X!
  33. 7135 T$=MKI$(X):RETURN
  34. 7150 X!=CVI(T$):IF X!=0 THEN T$="00/00/00":RETURN
  35. 7155 IF X!<=0 THEN X!=65536!+X!
  36. 7160 Y=1+INT((X!-.01)/365.25)
  37. 7165 K=X!-INT(365.25*(Y-1)):L=-1*(Y=4*INT(Y/4))
  38. 7170 I=K-(K>(59+L))*(2-L)+91:M=INT(I/30.55)-2
  39. 7175 D=I-INT(30.55*(M+2)):T$=FNN$(Y,2)+"/"+FNN$(M,2)+"/"+FNN$(D,2)
  40. 7180 IF Y>=100 THEN T$=CHR$(55+INT(Y/10))+MID$(T$,2)
  41. 7185 RETURN
  42. 7300 L=LEN(T$):N=1+INT((L-1)/3):U$=T$+SPACE$(3*N-L)
  43. 7305 M=0:T$="":FOR I=1 TO N:P!=0
  44. 7310 FOR J=1 TO 3:M=M+1:D=INSTR(A0$,MID$(U$,M,1))-1:IF D<0 THEN D=39
  45. 7315 P!=40*P!+D:NEXT J:IF P!<=32767 THEN Y=P! ELSE Y=P!-65536!
  46. 7320 T$=T$+MKI$(Y):NEXT I:RETURN
  47. 7350 U$=T$:T$="":FOR I=1 TO LEN(U$) STEP 2
  48. 7355 P!=CVI(MID$(U$,I,2)):IF P!<0 THEN P!=P!+65536!
  49. 7360 L=INT(P!/1600):P!=P!-1600*L:M=INT(P!/40):N=P!-40*M
  50. 7365 T$=T$+MID$(A0$,L+1,1)+MID$(A0$,M+1,1)+MID$(A0$,N+1,1)
  51. 7370 NEXT I:RETURN
  52. 9700 P7=P7+1:PRINT "[";FNS$(P7);"] ";
  53. 9705 PRINT DATE$;" ";TIME$:RETURN
  54. 9800 PRINT "ERR";ERR;" in line ";ERL
  55. 9805 STOP
  56. 9810 RESUME 1000
  57. 9999 END
  58.